home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / examples.zoo / misc / gruppen.lsp < prev    next >
Lisp/Scheme  |  1991-10-22  |  50KB  |  1,233 lines
  1. ; Behandlung von Gruppentheorie
  2. ; insbesondere Schreier-Sims-Algorithmus und Rubik's Cube-Gruppe
  3. ; außerdem Reduktion der Erzeugenden-Wort-Längen
  4. ; Bruno Haible, November-Dezember 1987
  5.  
  6. #+VAX
  7. (setq f "gruppen.lsp")
  8. #+VAX
  9. (defun c ()
  10.   (compile-file "gruppen.lsp" :output-file "gruppen.fas" :listing t)
  11. )
  12.  
  13.  
  14. (defvar *gruppen-trace* t)
  15. ; gibt an, ob kurze Meldungen auf dem Bildschirm erscheinen
  16.  
  17.  
  18. ; (intlist a b) ergibt (a a+1 ... b-1 b), wenn a und b integers sind.
  19. (proclaim '(function intlist (integer integer) list))
  20. (defun intlist (a b)
  21.   (do ((l nil (cons i l))
  22.        (i b (1- i)))
  23.       ((< i a) l)
  24. ) )
  25.  
  26. ; (list-rotate '(a1 a2 ... an)) ergibt '(a2 ... an a1)
  27. (proclaim '(function list-rotate (list) list))
  28. (defun list-rotate (l)
  29.   (append (rest l) (list (first l)))
  30. )
  31.  
  32. ; (search-min sequence predicate &key :key :default :from-end) sucht in einer
  33. ; Folge nach einem minimalen Element. (predicate x y) gibt an, wann x<y sein
  34. ; soll. :key ist eine Funktion, die aus jedem Element der Folge die zu
  35. ; vegleichende Größe bildet. :default ist der Wert, der sich bei der leeren
  36. ; Folge ergibt. Die Suche geschieht von links nach rechts und liefert das am
  37. ; weitesten links gelegene Minimum, bei :from-end t umgekehrt.
  38. ; Der erste Wert ist der Minimalwert, der zweite das fragliche Folgenelement.
  39. (defun search-min (seq pr &key (key #'identity) (default nil) (from-end nil)
  40.   &aux mel)
  41.   (if from-end (setq seq (reverse seq)))
  42.   (if (zerop (length seq))
  43.       default
  44.       (values (reduce #'(lambda (bisher-min el &aux (k (funcall key el)))
  45.                           (cond ((funcall pr k bisher-min)
  46.                                  (setq mel el) k)
  47.                                 (t bisher-min)
  48.                         ) )
  49.                       seq
  50.                       :start 1
  51.                       :initial-value (funcall key (setq mel (elt seq 0)))
  52.               )
  53.               mel
  54. ) )   )
  55.  
  56.  
  57. ;-------------------------------------------------------------------------------
  58. ; Die gerade aktuelle Gruppe (Defaultwert)
  59. (defvar *pgruppe*)
  60.  
  61. ;-------------------------------------------------------------------------------
  62. ; Datentyp der Permutation:
  63.  
  64. ; (injektiv a) stellt fest, ob eine Abbildung a (ein Array) injektiv ist
  65. ; und eine Permutation der Zahlen ab 1 aufwärts ist.
  66. (proclaim '(function injektiv (vector) atom))
  67. (defun injektiv (a)
  68.   (equal (sort (coerce a 'list) #'<) (intlist 1 (length a)))
  69. )
  70.  
  71. (deftype Mn (&optional n)
  72.   "Mn ist die Menge {1,...,n}"
  73.   ; `(integer (1) (,n)) gemeint
  74.   (declare (ignore n))
  75.   'integer
  76. )
  77.  
  78. (deftype perm (&optional n)
  79.   "PERM ist eine Permutation, als Abbildung dargestellt."
  80.   ; `(and (array (Mn ,n) (,n)) (satisfies injektiv)) gemeint
  81.   (declare (ignore n))
  82.   `(and (array t (*)) (satisfies injektiv))
  83. )
  84.  
  85.  
  86. ; Operationen auf Permutationen:
  87.  
  88. ; Anwendung einer Permutation auf eine Zahl
  89. (defmacro apply-perm (s i)
  90.   `(aref ,s (1- ,i))
  91. )
  92.  
  93. ; Aufbauen einer Permutation aus einer Liste l mit n Elementen
  94. (proclaim '(function make-perm (list) perm))
  95. (defun make-perm (l)
  96.   (let* ((n (length l))
  97.          (u (make-array `(,n) :element-type `(Mn ,n) )))
  98.     (do ((i 1 (1+ i))
  99.          (l l (cdr l)))
  100.         ((null l))
  101.       (setf (apply-perm u i) (car l))
  102.     )
  103.     (if (not (injektiv u)) (error "~S ist keine Permutation." u))
  104.     u
  105. ) )
  106.  
  107. ; Multiplikation zweier Permutationen: s nach t
  108. (proclaim '(function perm* (perm perm) perm))
  109. (defun perm* (s1 t1)
  110.    (let* ((n (length t1))
  111.           (u (make-array `(,n) :element-type `(Mn ,n) )))
  112.       (do ((i 1 (+ i 1)))
  113.           ((> i n))
  114.         (setf (apply-perm u i) (apply-perm s1 (apply-perm t1 i)))
  115.       )
  116.       u
  117. )  )
  118.  
  119. ; Invertieren einer Permutation
  120. (proclaim '(function perm/ (perm) perm))
  121. (defun perm/ (s)
  122.   (let* ((n (length s))
  123.          (u (make-array `(,n) :element-type `(Mn ,n))))
  124.     (do ((i 1 (1+ i)))
  125.         ((> i n))
  126.       (setf (apply-perm u (apply-perm s i)) i)
  127.     )
  128.     u
  129. ) )
  130.  
  131. ; neutrales Element (identische Abbildung)
  132. (proclaim '(function perm-id (&optional integer) perm))
  133. (defun perm-id (&optional (n (pgruppe-grad *pgruppe*)))
  134.   (let ((u (make-array `(,n) :element-type `(Mn ,n))))
  135.     (do ((i 1 (1+ i)))
  136.         ((> i n))
  137.       (setf (apply-perm u i) i)
  138.     )
  139.     u
  140. ) )
  141.  
  142. ; Test auf neutrales Element
  143. (proclaim '(function perm-id-p (perm &optional integer) atom))
  144. (defun perm-id-p (p &optional (n (length p)))
  145.   (do ((i 1 (1+ i)))
  146.       ((> i n) t)
  147.     (unless (= (apply-perm p i) i) (return-from perm-id-p nil))
  148. ) )
  149.  
  150. ; erzeugt eine Permutation aus ihrer Zyklendarstellung
  151. ; Permutation auf {1,...,n}, gegeben als Liste elementfremder Zyklen
  152. (proclaim '(function zykl-perm (list integer) perm))
  153. (defun zykl-perm (zl n)
  154.   (let ((u (perm-id n)))
  155.     (dolist (z zl)
  156.       (setf (apply-perm u (car (last z))) (first z))
  157.       (do ((l z (cdr l)))
  158.           ((endp (cdr l)))
  159.         (setf (apply-perm u (first l)) (second l))
  160.     ) )
  161.     (the perm u)
  162. ) )
  163.  
  164. ; erzeugt die Zyklendarstellung einer Permutation
  165. (proclaim '(function perm-zykl (perm) list))
  166. (defun perm-zykl (p)
  167.   (let ((n (length p)))
  168.     (do ((i 1 (1+ i))
  169.          (zl nil) ; Zyklenliste
  170.          (p1 (copy-seq p))) ; verändertes p
  171.         ((> i n) (nreverse zl))
  172.       ; Suche, ob bei i ein Zyklus anfängt
  173.       (unless (= (apply-perm p1 i) i)
  174.         (push (do ((j i)
  175.                    (z nil) ; Zyklus
  176.                    (flag nil t))
  177.                   ((and flag (= j i)) (nreverse z))
  178.                 (push j z)
  179.                 (rotatef (apply-perm p1 j) j)
  180.                 ; neues (apply-perm p1 j) := j,
  181.                 ; neues j := altes (apply-perm p1 j)
  182.               )
  183.               zl
  184.       ) )
  185. ) ) )
  186.  
  187.  
  188. ;-------------------------------------------------------------------------------
  189.  
  190. ; Datentyp des benannten Erzeugendensystems
  191.  
  192. ; Ein benanntes Erzeugendensystem ist eine Ansammlung von Permutationen, von
  193. ; denen jede einen Namem hat. Auf sie wird mit (aref1 ezs i) verwiesen.
  194. (deftype named-erz-sys (&optional n)
  195.   "ERZ-SYS ist eine Erzeugendensystem aus der Sn."
  196.   ; `(array (cons (perm ,n) string) (*)) gemeint
  197.   (declare (ignore n))
  198.   'vector
  199. )
  200.  
  201. ; (aref1 s i) ergibt allgemein das i-te Element (i=1,2,...) eines Arrays s.
  202. (defmacro aref1 (s i)
  203.   `(aref ,s (1- ,i))
  204. )
  205.  
  206. ; Aufbauen eines Erzeugendensystems aus einer Liste l von Permutationen
  207. (defun make-erz-sys (l)
  208.   (coerce (mapcar #'(lambda (p) (cons p "")) l) 'vector))
  209.  
  210.  
  211. ;-------------------------------------------------------------------------------
  212.  
  213. ; Datentyp des Erzeugendenprodukts:
  214.  
  215. ; In Bezug auf ein festes Erzeugendensystem ezs mit m Elementen:
  216. ; Die Erzeugenden werden durchnumeriert: 1,...,m für die angegebenen,
  217. ; -1,...,-m für ihre Inversen.
  218. ; Nun bedeutet ein Erzeugendenprodukt ezp = (t1 ... tk) das Produkt
  219. ; Et1 * .... * Etk.
  220.  
  221. (deftype ezp () 'list)
  222.  
  223. ; Multiplikation zweier Erzeugendendarstellungen: s nach t
  224. ; An der Nahtstelle werden Inverse bereits zusammengefaßt.
  225. (proclaim '(function ezp* (ezp ezp) ezp))
  226. (defun ezp* (s1 t1)
  227.   (do ((l1 (reverse s1) (cdr l1))
  228.        (l2 t1 (cdr l2)))
  229.       ((or (null l1) (null l2) (not (zerop (+ (car l1) (car l2)))))
  230.        (nreconc l1 l2))
  231. ) )
  232.  
  233. ; Invertieren einer Erzeugendendarstellung
  234. (proclaim '(function ezp/ (ezp) ezp))
  235. (defun ezp/ (s)
  236.   (nreverse (mapcar #'- s)))
  237.  
  238. ; Ausgeben eines Erzeugendenprodukts mit Hilfe eines benannten Erzeugenden-
  239. ; systems.
  240. (defun ezp-print (s nezs &optional (stream *standard-output*))
  241.   (if (null s)
  242.       (princ '"Id" stream)
  243.       (do ((l s))
  244.           ((endp l))
  245.         (let ((i (pop l)))
  246.           (princ (cdr (aref1 nezs (abs i))) stream)
  247.           (if (minusp i) (princ '"^-1" stream))
  248.         )
  249.         (unless (endp l) (princ '" * " stream))
  250. ) )   )
  251.  
  252.  
  253. (defconstant uses-ezprt nil "Wird eine Erzeugendenprodukttabelle verwendet?")
  254.  
  255. ; Um Erzeugendendarstellungen weiter vereinfachen zu können, brauchen wir
  256. ; eine Tabelle, die uns z.B. sagt, daß wir (5 -3 -4) zu (6) und somit auch
  257. ; (7 5 -3 -4 -6) zu (7 6 -6) und dann zu (7) vereinfachen können.
  258.  
  259. ; Datentyp einer Erzeugendenprodukt-Red